Celestin Apprentice 4/Apprentice-Release4.iso/Languages/CW MacMindy 1.4/Examples/Toolbox/Simple.dyl

Text File | 1995-11-15 | 12.4 KB | 440 lines | [TEXT/CWIE]

module:    Main

/*
  Simple.dyl

  Simple Macintosh Application example for Mindy Dylan.

  This demonstrates direct use of the Toolbox from Dylan.
  It is not a good example of how Dylan SHOULD be used.

  by Patrick C. Beard.
*/

define module Main
  use dylan;
  use extensions, import: { main, <equal-table>, <boolean> };
  use cheap-io;
  use threads;        // imports "spawn-thread".
  use extern;        // imports "<c-string>".
  use format, import: { format-to-string };
  use Toolbox;        // imports "Debugger", etc.
end module Main;

// menu constants.

define constant $MenuBar-ID =128;

define constant $Apple-Menu-ID = 128;
define constant $About-Item = 1;

define constant $File-Menu-ID = 129;
define constant $New-Item = 1;
define constant $Close-Item = 2;
define constant $Quit-Item = 4;

define constant $Edit-Menu-ID = 130;

define constant $Font-Menu-ID = 131;

// alert & dialog constants.

define constant $About-Alert-ID = 128;
define constant $Document-Window-ID = 128;
define constant $Cricket-snd-ID = 128;

// main!

define method main (argv0, #rest args)
    let menuBar = GetNewMBar($MenuBar-ID);
    if (menuBar ~= as(<MenuBarHandle>, 0))
    SetMenuBar(menuBar);
    FillMenu($Apple-Menu-ID, "DRVR");
    FillMenu($Font-Menu-ID, "FONT");
    DrawMenuBar();
    EventLoop();
    end if;
end method main;

define method FillMenu(menuID :: <integer>, typestr :: <string>)
    let menu = GetMenuHandle(menuID);
    if (menu ~= $nil)
    AppendResMenu(menu, os-type(typestr));
    end if;
end method FillMenu;

// get access to a C global that gets set when a "Quit" AppleEvent is received.
define constant theTimeToQuit = find-c-pointer("theTimeToQuit");
define constant collect-garbage = get-c-function("collect_garbage", args: #(), result: #());

// chirp like a cricket.

define constant $sound-resource-type = os-type("snd ");

define method chirp()
    let sound = GetResource($Sound-resource-type, $Cricket-snd-ID);
    if (sound ~= $nil)
    SndPlay($nil, sound, #f);
    ReleaseResource(sound);
    end if;
end method;

// an Alert event filter routine.

define method alert-filter (dialog :: <DialogPtr>, event :: <EventRecord>, itemHit :: <Ptr>)
     => (result :: <boolean>);
    //    Debugger();
    if (event-what(event) = $keyDown)
    chirp();
    signed-short-at(itemHit) := 1;
    #t;
    else
    #f;
    end if;
end method alert-filter;

define constant $alert-filter-callback = as (<ModalFilterUPP>,
                         make-c-callback(alert-filter,
                                 list(<DialogPtr>, <EventRecord>, <Ptr>),
                                 <boolean>, $uppModalFilterProcInfo));

// create a thread that blinks a rectangle in the front-most window.
define constant blink-rect = make(<Rect>, top: 1, left: 1, bottom: 3, right: 3);

define constant $qd-lock = make(<multilock>);

define method acquire-quickdraw (port :: <GrafPtr>)
    grab-lock($qd-lock);
    SetPort(port);
end method acquire-quickdraw;

define method release-quickdraw ()
    release-lock($qd-lock);
end method release-quickdraw;

define variable *blinkers-running* = #t;
define variable *blinker-exits* = 0;
define constant $blinker-lock = make(<multilock>);

define method blinker (window :: <WindowPtr>, period :: <integer>)
    let time-to-blink = TickCount() +  period;
    while (*blinkers-running*)
    if (TickCount() >= time-to-blink)
        acquire-quickdraw(window);
        InvertRect(blink-rect);
        release-quickdraw();
        time-to-blink := TickCount() +  period;
    end if;
    end while;
    // let the main event loop know we've exited the blinking phase by incrementing a counter.
    grab-lock($blinker-lock);
    *blinker-exits* := *blinker-exits* + 1;
    release-lock($blinker-lock);
    while (#t)
    end while;
end method blinker;

define method alarm-clock (h :: <integer>, m :: <integer>)
    let time = as(<DateTimeRec>, NewPtr(14));
    block(return)
    while (#t)
        SecondsToDate(GetDateTime(), time);
        if (time.hour = h & time.minute = m)
        SysBeep(1);
        end if;
    end while;
    cleanup
    destroy(time);
    end block;
end method;

define method EventLoop () => ();
    // some variables we'll need.
    let event = make(<EventRecord>);
    let message = as(<Pascal-string>, "you typed: '?'");
    let offset = size(message) - 2;
    let itemString = make (<Pascal-string>);
    let mouseRgn = NewRgn();
    let textRect = make(<Rect>, bottom: 32, right: 100);
    let sizeRect = make(<Rect>, top: 100, left: 100, bottom: 1000, right: 1000);
    let blinker-count = 0;
    let blinker-threads = make(<equal-table>);
    let quit-signaled = #f;

    // set an alarm for a particular hour and minute.
    // let alarm-thread = spawn-thread("alarm-clock", curry(alarm-clock, 8, 45));

    block (return)
    // draw window here.
    local method DrawWindow (window :: <WindowPtr>)
          // make sure we own this window.
          if (element(blinker-threads, window, default: #f) ~= #f)
              acquire-quickdraw(window);
              EraseRect(textRect);
              MoveTo(10, 16);
              DrawString(message);
              DrawGrowIcon(window);
              release-quickdraw();
          end if;
          end method;

    local method MakeWindow()
          let window = GetNewWindow($Document-Window-ID);
          if (window ~= $nil)
              blinker-count := blinker-count + 1;
              let thread-name = format-to-string("blinker %d", blinker-count);
              let thread = spawn-thread(thread-name, curry(blinker, window, 10));
              blinker-threads[window] := thread;
          end if;
          end method;

    local method RemoveWindow(window :: <WindowPtr>) => (result :: <boolean>);
          let thread = element(blinker-threads, window, default: #f);
          if (thread)
              kill-thread(thread);
              blinker-threads := remove-key!(blinker-threads, window);
              DisposeWindow(window);
              blinker-count := blinker-count - 1;
              #t;
          else
              #f;
          end if;
          end method;

    local method DoAbout()
          chirp();
          Alert($About-Alert-ID, filter: $alert-filter-callback);
          end method;

    // pre-process menu states.
    local method UpdateMenus()
          let fileMenu = GetMenuHandle($File-Menu-ID);
          let fontMenu = GetMenuHandle($Font-Menu-ID);
          if (FrontWindow() ~= $nil)
              EnableItem(fileMenu, $Close-Item);
              EnableItem(fontMenu, 0);
          else
              DisableItem(fileMenu, $Close-Item);
              DisableItem(fontMenu, 0);
          end if;
          DrawMenuBar();
          end method;

    // process menu selections.
    local method DoMenu (menu, item)
          if (menu ~= 0 & item ~= 0)
              select (menu by \=)
              $Apple-Menu-ID =>
                  if (item = $About-Item)
                  DoAbout();
                  else
                  GetMenuItemText(GetMenuHandle($Apple-Menu-ID), item, itemString);
                  OpenDeskAcc(itemString);
                  end if;
              $File-Menu-ID =>
                  select (item by \=)
                  $New-Item =>
                      MakeWindow();
                  $Close-Item =>
                      let window = FrontWindow();
                      if (window ~= $nil)
                      RemoveWindow(window);
                      end if;
                  $Quit-Item =>
                      quit-signaled := #t;
                      // return();
                  end select;
              $Font-Menu-ID =>
                  let window = FrontWindow();
                  if (window ~= $nil)
                  GetMenuItemText(GetMenuHandle($Font-Menu-ID), item, itemString);
                  let font-number = GetFNum(itemString);
                  acquire-quickdraw(window);
                  TextFont(font-number);
                  DrawWindow(window);
                  release-quickdraw();
                  end if;
              otherwise =>
                  GetMenuItemText(GetMenuHandle(menu), item, itemString);
                  DebugStr(itemString);
              end select;
          end if;
          HiliteMenu(0);
          UpdateMenus();
          end method;

    local method RubberBand (window :: <WindowPtr>)
          let where = event-where(event);
          // create a <Point> on the stack.
          let localWhere = stack-alloc(<Point>, 4);
          localWhere.point-v := where.point-v;
          localWhere.point-h := where.point-h;
          acquire-quickdraw(window);
          GlobalToLocal(localWhere);
          release-quickdraw();
          block (return)
              // create a <Rect> on the stack.
              let lassoRect = stack-alloc(<Rect>, 8);
              lassoRect.top := point-v(localWhere);
              lassoRect.left := point-h(localWhere);
              lassoRect.bottom := point-h(localWhere);
              lassoRect.right := point-v(localWhere);
              acquire-quickdraw(window);
              PenMode($patXor);
              FrameRect(lassoRect);
              release-quickdraw();
              while (StillDown())
              acquire-quickdraw(window);
              GetMouse(localWhere);
              release-quickdraw();
              if (point-h(localWhere) ~= lassoRect.right | point-v(localWhere) ~= lassoRect.bottom)
                  acquire-quickdraw(window);
                  FrameRect(lassoRect);
                  lassoRect.bottom := point-v(localWhere);
                  lassoRect.right := point-h(localWhere);
                  FrameRect(lassoRect);
                  release-quickdraw();
              end if;
              end while;
              acquire-quickdraw(window);
              FrameRect(lassoRect);
              PenMode($patOr);
              release-quickdraw();
          end block;
          // print(localWhere);
          // fflush();
          values(#"chirp");
          end method;

    // process mouse clicks.
    local method DoClick (event :: <EventRecord>)
          let (partCode, window) = FindWindow(event-where(event));
          select (partCode)
              $inMenuBar =>
              UpdateMenus();
              let (menu, item) = MenuSelect(event-where(event));
              DoMenu(menu, item);
              $inDesk =>
              #f;
              $inDrag =>
              DragWindow(window, event-where(event));
              $inContent =>
              SelectWindow(window);
              if (RubberBand(window) == #"chirp") chirp(); end if;
              $inGoAway =>
              if (TrackGoAway(window, event-where(event)))
                  RemoveWindow(window);
                  UpdateMenus();
              end if;
              $inZoomIn, $inZoomOut =>
              if (TrackBox(window, event-where(event), partCode))
                  acquire-quickdraw(window);
                  EraseRect(window.portRect);
                  ZoomWindow(window, partCode, #t);
                  release-quickdraw();
              end if;
              $inGrow =>
              let (height, width) = GrowWindow(window, event-where(event), sizeRect);
              if (height ~= 0 & width ~= 0)
                  acquire-quickdraw(window);
                  SizeWindow(window, width, height, #f);
                  EraseRect(window.portRect);
                  DrawWindow(window);
                  release-quickdraw();
              end if;
              otherwise =>
              #f;
          end select;
          end method;

    // process keystrokes.
    local method DoKey (event :: <EventRecord>)
          let ch = as(<character>, logand(event-message(event), 255));
          if (logand(event-modifiers(event), $cmdKey) = $cmdKey)
              UpdateMenus();
              let (menu, item) = MenuKey(ch);
              DoMenu(menu, item);
          else
              message[offset] := ch;
              let window = FrontWindow();
              if (window ~= $nil)
              DrawWindow(window)
              else
              DebugStr(message);
              end if;
              // break("yes: %=", ch);
          end if;
          end method;

    // process update events.
    local method DoUpdate (event :: <EventRecord>)
          let window = as(<WindowPtr>, event-message(event));
          BeginUpdate(window);
          DrawWindow(window);
          EndUpdate(window);
          end method;

    // process activate events.
    local method DoActivate (event :: <EventRecord>)
          let window = as(<WindowPtr>, event-message(event));
          DrawWindow(window);
          end method;

    // override the default Quit AppleEvent handler.
    local method HandleQuitEvent (event :: <AppleEvent>, reply :: <AppleEvent>, refCon :: <integer>)
           => (result :: <OSErr>);
          quit-signaled := #t;
          values(0);
          end method;

    let quit-handler = as (<AEEventHandlerUPP>,
                   make-c-callback(HandleQuitEvent, list(<AppleEvent>, <AppleEvent>, <integer>),
                           <OSErr>, $uppAEEventHandlerProcInfo));

    let result = AEInstallEventHandler($kCoreEventClass, $kAEQuitApplication, quit-handler, 0, #f);

    // get initial state right.
    UpdateMenus();

    // the event loop goes on until somebody quits.
    while (~quit-signaled)
        if (WaitNextEvent($everyEvent, event, 5, mouseRgn))
        select (event-what(event))
            $mouseDown =>
            DoClick(event);
            $keyDown =>
            DoKey(event);
            $updateEvt =>
            DoUpdate(event);
            $activateEvt =>
            DoActivate(event);
            $kHighLevelEvent =>
            result := AEProcessAppleEvent(event);
            otherwise =>
            #f;
        end select;
        end if;
    end while;

    // shut down all the blinker threads.
    *blinkers-running* := #f;
    while (*blinker-exits* ~= blinker-count)
    end while;

    // close all the windows.
    for (window in key-sequence(blinker-threads))
        RemoveWindow(window);
    end for;

    cleanup
    destroy(event);
    destroy(message);
    destroy(itemString);
    DisposeRgn(mouseRgn);
    destroy(textRect);
    destroy(sizeRect);
    // kill-thread(alarm-thread);
    destroy-callbacks();
    end block;
end method EventLoop;